home *** CD-ROM | disk | FTP | other *** search
/ Just Call Me Internet / Just Call Me Internet.iso / prog / atari / m2 / cat3src / magic / i / mtxobjec.i < prev    next >
Encoding:
Modula Implementation  |  1997-10-26  |  10.3 KB  |  285 lines
  1. (*----------------------------------------------------------------------*
  2.  *                                                                      *
  3.  *  MAGICTOOLS   Modula's  All purpose  GEM  Interface  Cadre  Toolbox  *
  4.  *               ÿ         ÿ            ÿ    ÿ          ÿ               *
  5.  *----------------------------------------------------------------------*
  6.  * Version 3.30  02.02.1992     (C)90/91/92 by Peter Hellinger Software *
  7.  *----------------------------------------------------------------------*
  8.  *            Dieses Modul ist urheberrechtlich geschtzt.              *
  9.  *                                                                      *
  10.  * Die Ver”ffentlichung des Quelltextes oder Teilen daraus, sowie die   *
  11.  * Verbreitung des bersetzten, nicht gelinkten Codes in schriftlicher, *
  12.  * oder maschinenlesbarer Form, insbesondere in Zeitschriften, Mail-    *
  13.  * boxen oder anderen Medien bedarf der ausdrcklichen schriftlichen    *
  14.  * Einverst„ndnisserkl„rung des Autors.                                 *
  15.  *                                                                      *
  16.  * Die Verbreitung des Moduls als Teil eines gelinkten Programms ist    *
  17.  * fr Lizenznehmer ausdrcklich erlaubt!  Der Autor beh„lt sich das    *
  18.  * Recht vor, diese Erlaubnis jederzeit und ohne Angaben von Grnden zu *
  19.  * widerrufen.                                                          *
  20.  *----------------------------------------------------------------------*)
  21.  
  22. IMPLEMENTATION MODULE mtXobjects;
  23.  
  24. (*----------------------------------------------------------------------*
  25.  * Int. Vers | Datum    | Name | Žnderung                               *
  26.  *-----------+----------+------+----------------------------------------*
  27.  *  1.00     | 02.02.92 |  Hp  |                                        *
  28.  *  1.01     | 09.02.92 |  Hp  | Handler verbessert. Macht jetzt auch   *
  29.  *           |          |      | keine Probleme mehr bei Objekten in    *
  30.  *           |          |      | der Menzeile.                         *
  31.  *-----------+----------+------+----------------------------------------*)
  32.  
  33.  
  34.  
  35. (* IMPLEMENTATION FšR  >>> Megamax-Modula-2 <<< *)
  36. (*                                              *)
  37. (*$R-   Range-Checks                            *)
  38. (*$S-   Stack-Check                             *)
  39. (*                                              *)
  40. (*----------------------------------------------*)
  41.  
  42.  
  43.  
  44.  
  45.  
  46.  
  47. FROM MagicSys   IMPORT  Nil, Null, Bit0, Bit1, Bit2, Bit3, Bit4, Bit5, Bit6,
  48.                         Bit7, Bit8, Bit9, Bit10, Bit11, Bit12, Bit13, Bit14,
  49.                         Bit15, LOC, Byte, ByteSet, sWORD, sINTEGER, sCARDINAL,
  50.                         sBITSET, lINTEGER, lCARDINAL, lWORD, lBITSET,
  51.                         CastToChar, CastToByte, CastToByteset, CastToInt,
  52.                         CastToCard, CastToBitset, CastToWord, CastToLInt,
  53.                         CastToLCard, CastToLBitset, CastToLWord, CastToAddr,
  54.                         TosVersion, Accessory, Basepage, SysHeader, TosDate;
  55.  
  56.  
  57.  
  58.  
  59.  
  60.  
  61.  
  62.  
  63. FROM Storage IMPORT ALLOCATE, DEALLOCATE;
  64.  
  65.  
  66.  
  67.  
  68. IMPORT SYSTEM, MagicAES;
  69.  
  70. CONST   Stacksize =     4096; (* 4kb Stack *)
  71.  
  72. TYPE    tTree =         POINTER TO ARRAY [0..MAX (sINTEGER)] OF MagicAES.OBJECT;
  73.  
  74. TYPE    PtrUSERBLK =    POINTER TO USERBLK; (* Intern erweitert! *)
  75.         USERBLK =       RECORD
  76.                          ubCode: PROC;              (* Standard AES *)
  77.                          ubPara: MagicAES.Objcspec; (* Standard AES *)
  78.                          obType: sINTEGER;          (* Magic Erweiterung *)
  79.                          draw:   DrawProc;          (* Magic Erweiterung *)
  80.                          priv:   SYSTEM.ADDRESS;    (* Magic Erweiterung *)
  81.                         END;
  82.  
  83. TYPE    PBLK =          RECORD
  84.                          pbTree:      tTree;
  85.                          pbObj:       sINTEGER;
  86.                          prPrevstate: BITSET;
  87.                          prCurrstate: BITSET;
  88.                          pbX:         sINTEGER;
  89.                          pbY:         sINTEGER;
  90.                          pbW:         sINTEGER;
  91.                          pbH:         sINTEGER;
  92.                          pbXc:        sINTEGER;
  93.                          pbYc:        sINTEGER;
  94.                          pbWc:        sINTEGER;
  95.                          pbHc:        sINTEGER;
  96.                          pbParm:      SYSTEM.ADDRESS;
  97.                         END;
  98.  
  99. VAR     pblkptr:        SYSTEM.ADDRESS;
  100.         pblk:           PBLK;
  101.         uPtr:           PtrUSERBLK;
  102.         return:         sBITSET;        
  103.         regUSP:         SYSTEM.LONGWORD;
  104.         regSSP:         SYSTEM.LONGWORD;
  105.         regSR:          SYSTEM.WORD;
  106.         regs:           ARRAY[0..15] OF SYSTEM.LONGWORD;
  107.         stack:          ARRAY [0..Stacksize-1] OF SYSTEM.BYTE;
  108.         stackA7:        SYSTEM.ADDRESS; (* Adresse des A7-Stacks *)
  109.         stackA3:        SYSTEM.ADDRESS; (* Adresse des A3-Stacks *)
  110.         set:            sBITSET;
  111.  
  112.  
  113. PROCEDURE Callproc;
  114. BEGIN
  115.  (* Im obSpec steht der Zeiger auf den Userblock *)
  116.  uPtr:= pblk.pbTree^[pblk.pbObj].obSpec.address;
  117.  set:= uPtr^.draw (pblkptr);
  118.  regs[0]:= SYSTEM.CAST (SYSTEM.LONGWORD, set);
  119.  (* In regs[0] ist D0 gespeichert. Hier legen wir gleich unseren Return-
  120.   * Parameter ab. Handler schreibt regs automatisch wieder zurck.
  121.   *)
  122. END Callproc;
  123.  
  124. (*$L-   Parameterbergabe durch Assembler *)
  125. (*$J-   Optimierungen aus (vorsichtshalber) *)
  126. (*$S-   Kein Stackcheck! (Sonst bei Aufruf Stack-Error!) *)
  127. (*$R-   Kein Rangecheck! (Sonst Bomben!) *)
  128.  
  129. PROCEDURE Handler;
  130. (* Diese Prozedur wird direkt vom AES aufgerufen, schafft eine Modula-Umgebung,
  131.  * und leitet den Aufruf an Callproc weiter. Callproc sucht dann den Userblk
  132.  * fr das Objekt und ruft die Zeichenroutine auf, so als ob diese von einer
  133.  * Modula-2 Prozedur gerufen wurde.  Anschliežend werden die Rckgabe-Parameter
  134.  * C-m„žig zusammengestellt und in das AES zurckgekehrt.
  135.  *)
  136. BEGIN
  137.  SYSTEM.ASSEMBLER
  138.   MOVEM.L D0-D7/A0-A6,regs      ; Register retten, damit wir beim Austritt aus
  139.  
  140.   MOVE    SR,regSR              ; Statusregister sichern
  141.   ORI     #$700,SR              ; Interrupts sperren
  142.   
  143.   MOVE.L  USP,A1                ; Handler wieder gleich dastehen
  144.   MOVE.L  A1,regUSP             ; Userstackpointer
  145.   MOVE.L  A7, regSSP            ; Supervisorstack
  146.   MOVE    regSR,SR              ; Interrupts wieder freigeben
  147.  
  148.   MOVE.L  4(A7),A1              ; Hole Zeiger auf ParamBlock in A1
  149.  
  150.   LEA     pblk, A0              ; Globalen Parameterblock in A0
  151.  
  152.   MOVE.L  (A1)+,pblk.pbTree(A0) ; Parameterblock beschreiben
  153.   MOVE.W  (A1)+,pblk.pbObj(A0)
  154.   MOVE.W  (A1)+,pblk.prPrevstate(A0)
  155.   MOVE.W  (A1)+,pblk.prCurrstate(A0)
  156.   MOVE.W  (A1)+,pblk.pbX(A0)
  157.   MOVE.W  (A1)+,pblk.pbY(A0)
  158.   MOVE.W  (A1)+,pblk.pbW(A0)
  159.   MOVE.W  (A1)+,pblk.pbH(A0)
  160.   MOVE.W  (A1)+,pblk.pbXc(A0)
  161.   MOVE.W  (A1)+,pblk.pbYc(A0)
  162.   MOVE.W  (A1)+,pblk.pbWc(A0)
  163.   MOVE.W  (A1)+,pblk.pbHc(A0)
  164.   MOVE.L  (A1)+,pblk.pbParm(A0)
  165.   
  166. ;  ANDI.W  #-1-$2000,SR          ; Wechsle in den Usermode
  167.  
  168.   MOVE.L  stackA3,A3            ; Stack fr -Parameter
  169.   MOVE.L  stackA7,A7            ; Prozessor-Stack
  170.  
  171.   JSR     Callproc              ; Caller aufrufen, Tunsdinge verrichten
  172.  
  173. ;  CLR.L   -(A7)                 ; Zurck in Supervisormode
  174. ;  MOVE    #$20,-(A7)            ; ber GEMDOS.Super
  175. ;  TRAP    #1
  176. ;  ADDQ.L  #6, A7
  177.  
  178.                                 ; Interrupts alle ausschalten 
  179.   MOVE    SR,regSR              ; Statusregister sichern
  180.   ORI     #$700,SR              ; Interrupts sperren
  181.   
  182.   MOVE.L  regSSP, A7            ; Register restaurieren
  183.   MOVE.L  regUSP,A1
  184.   MOVE.L  A1,USP
  185.   MOVE    regSR,SR              ; Interrupts wieder freigeben
  186.   
  187.   MOVEM.L regs,D0-D7/A0-A6      ; Zurck ins AES
  188.  END; (* ASSEMBLER *)
  189. END Handler;
  190. (*$L=, J=*)
  191.  
  192.  
  193. PROCEDURE InstUserdef (tree: SYSTEM.ADDRESS; objc: sINTEGER;
  194.                        proc: DrawProc; private: SYSTEM.ADDRESS): BOOLEAN;
  195. VAR uPtr: PtrUSERBLK;
  196.     t:    tTree;
  197. BEGIN
  198.  t:= tree;
  199.  IF t^[objc].obType # MagicAES.GPROGDEF THEN (* noch kein Progdef! *)  
  200.   (* Neuer Userblock fr das Objekt *)
  201.   ALLOCATE (uPtr,  SYSTEM.TSIZE (USERBLK));  
  202.   IF uPtr # NIL THEN
  203.    (* Userblock beschreiben *)
  204.     uPtr^.ubCode:= Handler; (* Handler eintragen *) 
  205.    
  206.    uPtr^.ubPara:= t^[objc].obSpec; (* obSpec retten *)
  207.    uPtr^.obType:= t^[objc].obType; (* obType retten *)
  208.    uPtr^.draw:=   proc; (* Die eigentliche Zeichenprozedur *)
  209.    uPtr^.priv:= private; (* Zusatzparameter *)
  210.    t^[objc].obType:= MagicAES.GPROGDEF; (* Objekttyp „ndern *)
  211.    t^[objc].obSpec.address:= uPtr; (* obSpec auf Userblock umbiegen *)
  212.    RETURN TRUE;
  213.   END;
  214.   RETURN FALSE;
  215.  END;
  216.  RETURN TRUE;
  217. END InstUserdef;
  218.  
  219. PROCEDURE FreeUserdef (tree: SYSTEM.ADDRESS; objc: sINTEGER);
  220. VAR uPtr: PtrUSERBLK;
  221.     t:    tTree;
  222. BEGIN
  223.  t:= tree;
  224.  IF t^[objc].obType = MagicAES.GPROGDEF THEN
  225.   uPtr:= t^[objc].obSpec.address; (* Userblock holen *)
  226.   t^[objc].obType:= uPtr^.obType; (* obType restaurieren *)
  227.   t^[objc].obSpec:= uPtr^.ubPara; (* obSpec restaurieren *)
  228.   DEALLOCATE (uPtr, 0);  
  229.  END;
  230. END FreeUserdef;
  231.  
  232. PROCEDURE GetObtype (tree: SYSTEM.ADDRESS; objc: sINTEGER): sINTEGER;
  233. VAR uPtr: PtrUSERBLK;
  234.     t:    tTree;
  235. BEGIN
  236.  t:= tree;
  237.  IF t^[objc].obType = MagicAES.GPROGDEF THEN
  238.   uPtr:= t^[objc].obSpec.address;
  239.   RETURN uPtr^.obType; (* gemerkten Objekttyp liefern *)
  240.  END;
  241.  RETURN t^[objc].obType; (* Original-Objekttyp liefern *)
  242. END GetObtype;
  243.  
  244. PROCEDURE GetObSpec (tree: SYSTEM.ADDRESS; objc: sINTEGER): SYSTEM.ADDRESS;
  245. VAR uPtr: PtrUSERBLK;
  246.     t:    tTree;
  247. BEGIN
  248.  t:= tree;
  249.  IF t^[objc].obType = MagicAES.GPROGDEF THEN
  250.   uPtr:= t^[objc].obSpec.address;  RETURN uPtr^.ubPara.address;
  251.  END;
  252.  RETURN t^[objc].obSpec.address;
  253. END GetObSpec;
  254.  
  255. PROCEDURE GetPrivate (tree: SYSTEM.ADDRESS; objc: sINTEGER): SYSTEM.ADDRESS;
  256. VAR uPtr: PtrUSERBLK;
  257.     t:    tTree;
  258. BEGIN
  259.  t:= tree;
  260.  IF t^[objc].obType = MagicAES.GPROGDEF THEN
  261.   uPtr:= t^[objc].obSpec.address;  RETURN uPtr^.priv;
  262.  END;
  263.  RETURN NIL;
  264. END GetPrivate;
  265.  
  266. VAR init : INTEGER;
  267.  
  268. PROCEDURE InitMtXobjects();
  269. BEGIN
  270.  IF init # 27895
  271.  THEN
  272.    pblkptr:= SYSTEM.ADR (pblk);
  273.  
  274.    stackA7:= SYSTEM.ADR (stack) + Stacksize;  stackA3:= SYSTEM.ADR (stack);
  275.     
  276.    init := 27895
  277.  END;
  278. END InitMtXobjects;
  279.  
  280. BEGIN
  281.   init := 0;
  282.   InitMtXobjects;
  283. END mtXobjects.
  284.  
  285.